Исходный код

Option Explicit
Call ChangeStatus(ThisObject)


'==============================================================================
'Изменить текущий статус объекта на указанный пользователем.
'==============================================================================
Sub ChangeStatus(Obj)

        Dim FinalStat, Stat, ChildObj, i, SelDlg, RetVal, ChosenSts
        
        'Заполнить массив ссылками на допустимые статусы объекта (кроме текущего)
        i=-1
        For Each Stat In Obj.ObjectDef.Statuses
                If Stat.SysName <> Obj.Status.SysName Then
                        i=i+1
                        ReDim Preserve ArStatus(i)
                        Set ArStatus(i) = Stat
                End If
        Next
        
        'Открыть диалог выбора, передав на вход массив допустимых статусов
        Set SelDlg = ThisApplication.Dialogs.SelectDlg
        SelDlg.SelectFrom = ArStatus
        SelDlg.Caption = "Статусы объекта"
        SelDlg.Prompt = "Выберите статус для установки:"
        RetVal = SelDlg.Show
        
        'Если пользователь отменил диалог или выбрал не один статус, выйти из процедуры
        If (Not RetVal) Or (UBound(SelDlg.Objects)<>0) Then Exit Sub
        
        'Получить ссылку на выбранный статус
        ChosenSts = SelDlg.Objects
        Set Stat = ChosenSts(0)
        
        'Если статус - конечный, то для его установки все объекты состава также должны 
        'иметь конечный статус.
        If Stat.Final Then
                'Проверяем все объекты состава
                For Each ChildObj In Obj.Content
                        If ChildObj.Status.Final<>TRUE Then
                                MsgBox "Смена статуса на конечный невозможна" & Chr(13) &_
                                            "(не все объекты состава имеют конечный статус.)", vbExclamation
                                Exit Sub
                        End If
                Next
        End If 
        
        'Включим собственный перехват ошибок
        On Error Resume Next                        

        'Пробуем сменить статус объекта.
        Obj.Permissions = SysAdminPermissions
        Obj.Status = Stat

        'Если была ошибка...
        If Err<>0 Then         MsgBox "Ошибка смены статуса " & StrSysName & "." &_
                                Chr(13) & "Код ошибки: " & Err, vbExclamation
End Sub
'==============================================================================